home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / combin.lisp < prev    next >
Lisp/Scheme  |  1992-12-21  |  15KB  |  404 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package :pcl)
  29.  
  30. (defun get-method-function (method &optional method-alist wrappers)
  31.   (let ((fn (cadr (assoc method method-alist))))
  32.     (if fn
  33.     (values fn nil nil nil)
  34.     (multiple-value-bind (mf fmf)
  35.         (if (listp method)
  36.         (early-method-function method)
  37.         (values nil (method-fast-function method)))
  38.       (let* ((pv-table (and fmf (method-function-pv-table fmf))))
  39.         (if (and fmf (or (null pv-table) wrappers))
  40.         (let* ((pv-wrappers (when pv-table 
  41.                       (pv-wrappers-from-all-wrappers
  42.                        pv-table wrappers)))
  43.                (pv-cell (when (and pv-table pv-wrappers)
  44.                   (pv-table-lookup pv-table pv-wrappers))))
  45.           (values mf t fmf pv-cell))
  46.         (values 
  47.          (or mf (if (listp method)
  48.                 (setf (cadr method)
  49.                   (method-function-from-fast-function fmf))
  50.                 (method-function method)))
  51.          t nil nil)))))))
  52.  
  53. (defun make-effective-method-function (generic-function form &optional 
  54.                        method-alist wrappers)
  55.   (funcall (make-effective-method-function1 generic-function form
  56.                         (not (null method-alist))
  57.                         (not (null wrappers)))
  58.        method-alist wrappers))
  59.  
  60. (defun make-effective-method-function1 (generic-function form 
  61.                     method-alist-p wrappers-p)
  62.   (if (and (listp form)
  63.        (eq (car form) 'call-method))
  64.       (make-effective-method-function-simple generic-function form)
  65.       ;;
  66.       ;; We have some sort of `real' effective method.  Go off and get a
  67.       ;; compiled function for it.  Most of the real hair here is done by
  68.       ;; the GET-FUNCTION mechanism.
  69.       ;; 
  70.       (make-effective-method-function-internal generic-function form
  71.                            method-alist-p wrappers-p)))
  72.  
  73. (defun make-effective-method-function-type (generic-function form
  74.                         method-alist-p wrappers-p)
  75.   (if (and (listp form)
  76.        (eq (car form) 'call-method))
  77.       (let* ((cm-args (cdr form))
  78.          (method (car cm-args)))
  79.     (when method
  80.       (if (if (listp method)
  81.           (eq (car method) ':early-method)
  82.           (method-p method))
  83.           (if method-alist-p
  84.           't
  85.           (multiple-value-bind (mf fmf)
  86.               (if (listp method)
  87.               (early-method-function method)
  88.               (values nil (method-fast-function method)))
  89.             (declare (ignore mf))
  90.             (let* ((pv-table (and fmf (method-function-pv-table fmf))))
  91.               (if (and fmf (or (null pv-table) wrappers-p))
  92.               'fast-method-call
  93.               'method-call))))
  94.           (if (and (consp method) (eq (car method) 'make-method))
  95.           (make-effective-method-function-type 
  96.            generic-function (cadr method) method-alist-p wrappers-p)
  97.           (type-of method)))))
  98.       'fast-method-call))
  99.  
  100. (defun make-effective-method-function-simple (generic-function form
  101.                                    &optional no-fmf-p)
  102.   ;;
  103.   ;; The effective method is just a call to call-method.  This opens up
  104.   ;; the possibility of just using the method function of the method as
  105.   ;; the effective method function.
  106.   ;;
  107.   ;; But we have to be careful.  If that method function will ask for
  108.   ;; the next methods we have to provide them.  We do not look to see
  109.   ;; if there are next methods, we look at whether the method function
  110.   ;; asks about them.  If it does, we must tell it whether there are
  111.   ;; or aren't to prevent the leaky next methods bug.
  112.   ;; 
  113.   (let* ((cm-args (cdr form))
  114.      (fmf-p (and (null no-fmf-p)
  115.              (or (not (eq *boot-state* 'complete))
  116.              (gf-fast-method-function-p generic-function))
  117.              (null (cddr cm-args))))
  118.      (method (car cm-args))
  119.      (cm-args1 (cdr cm-args)))
  120.     #'(lambda (method-alist wrappers)
  121.     (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
  122.                         method-alist wrappers))))
  123.  
  124. (defun make-emf-from-method (method cm-args &optional gf fmf-p method-alist wrappers)
  125.   (multiple-value-bind (mf real-mf-p fmf pv-cell)
  126.       (get-method-function method method-alist wrappers)
  127.     (if fmf
  128.     (let* ((next-methods (car cm-args))
  129.            (next (make-effective-method-function-simple1
  130.               gf (car next-methods)
  131.               (list* (cdr next-methods) (cdr cm-args))
  132.               fmf-p method-alist wrappers))
  133.            (arg-info (method-function-get fmf ':arg-info)))
  134.       (make-fast-method-call :function fmf
  135.                  :pv-cell pv-cell
  136.                  :next-method-call next
  137.                  :arg-info arg-info))
  138.     (if real-mf-p
  139.         (make-method-call :function mf
  140.                   :call-method-args cm-args)
  141.         mf))))
  142.  
  143. (defun make-effective-method-function-simple1 (gf method cm-args fmf-p
  144.                           &optional method-alist wrappers)
  145.   (when method
  146.     (if (if (listp method)
  147.         (eq (car method) ':early-method)
  148.         (method-p method))
  149.     (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
  150.     (if (and (consp method) (eq (car method) 'make-method))
  151.         (make-effective-method-function gf (cadr method) method-alist wrappers)
  152.         method))))
  153.  
  154. (defvar *global-effective-method-gensyms* ())
  155. (defvar *rebound-effective-method-gensyms*)
  156.  
  157. (defun get-effective-method-gensym ()
  158.   (or (pop *rebound-effective-method-gensyms*)
  159.       (let ((new (intern (format nil "EFFECTIVE-METHOD-GENSYM-~D" 
  160.                  (length *global-effective-method-gensyms*))
  161.              "PCL")))
  162.     (setq *global-effective-method-gensyms*
  163.           (append *global-effective-method-gensyms* (list new)))
  164.     new)))
  165.  
  166. (let ((*rebound-effective-method-gensyms* ()))
  167.   (dotimes (i 10) (get-effective-method-gensym)))
  168.  
  169. (defun expand-effective-method-function (gf effective-method &optional env)
  170.   (declare (ignore env))
  171.   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
  172.       (get-generic-function-info gf)
  173.     (declare (ignore nreq nkeys arg-info))
  174.     `(lambda ,(make-fast-method-call-lambda-list metatypes applyp)
  175.        (declare (ignore .pv-cell. .next-method-call.))
  176.        ,effective-method)))
  177.  
  178. (defun expand-emf-call-method (gf form metatypes applyp env)
  179.   (declare (ignore gf metatypes applyp env))
  180.   `(call-method ,(cdr form)))
  181.  
  182. (defmacro call-method (&rest args)
  183.   (declare (ignore args))
  184.   `(error "~S outsize of a effective method form" 'call-method))
  185.  
  186. (defun memf-test-converter (form generic-function method-alist-p wrappers-p)
  187.   (cond ((and (consp form) (eq (car form) 'call-method))
  188.      (case (make-effective-method-function-type 
  189.         generic-function form method-alist-p wrappers-p)
  190.        (fast-method-call
  191.         '.fast-call-method.)
  192.        (t
  193.         '.call-method.)))
  194.     ((and (consp form) (eq (car form) 'call-method-list))
  195.      (case (if (every #'(lambda (form)
  196.                   (eq 'fast-method-call
  197.                   (make-effective-method-function-type 
  198.                    generic-function form 
  199.                    method-alist-p wrappers-p)))
  200.               (cdr form))
  201.            'fast-method-call
  202.            't)
  203.        (fast-method-call
  204.         '.fast-call-method-list.)
  205.        (t
  206.         '.call-method-list.)))
  207.     (t
  208.      (default-test-converter form))))
  209.  
  210. (defun memf-code-converter (form generic-function 
  211.                  metatypes applyp method-alist-p wrappers-p)
  212.   (cond ((and (consp form) (eq (car form) 'call-method))
  213.      (let ((gensym (get-effective-method-gensym)))
  214.        (values (make-emf-call metatypes applyp gensym
  215.                   (make-effective-method-function-type 
  216.                    generic-function form method-alist-p wrappers-p))
  217.            (list gensym))))
  218.     ((and (consp form) (eq (car form) 'call-method-list))
  219.      (let ((gensym (get-effective-method-gensym))
  220.            (type (if (every #'(lambda (form)
  221.                     (eq 'fast-method-call
  222.                     (make-effective-method-function-type 
  223.                      generic-function form 
  224.                      method-alist-p wrappers-p)))
  225.                 (cdr form))
  226.              'fast-method-call
  227.              't)))
  228.        (values `(dolist (emf ,gensym nil)
  229.               ,(make-emf-call metatypes applyp 'emf type))
  230.            (list gensym))))             
  231.     (t
  232.      (default-code-converter form))))
  233.  
  234. (defun memf-constant-converter (form generic-function)
  235.   (cond ((and (consp form) (eq (car form) 'call-method))
  236.      (list (cons '.meth.
  237.              (make-effective-method-function-simple
  238.               generic-function form))))
  239.     ((and (consp form) (eq (car form) 'call-method-list))
  240.      (list (cons '.meth-list.
  241.              (mapcar #'(lambda (form)
  242.                  (make-effective-method-function-simple
  243.                   generic-function form))
  244.                  (cdr form)))))
  245.     (t
  246.      (default-constant-converter form))))
  247.  
  248. (defun make-effective-method-function-internal (generic-function effective-method
  249.                             method-alist-p wrappers-p)
  250.   (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
  251.       (get-generic-function-info generic-function)
  252.     (declare (ignore nkeys arg-info))
  253.     (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
  254.        (name (if (early-gf-p generic-function)
  255.              (early-gf-name generic-function)
  256.              (generic-function-name generic-function)))
  257.        (arg-info (cons nreq applyp))
  258.        (effective-method-lambda (expand-effective-method-function
  259.                      generic-function effective-method)))
  260.       (multiple-value-bind (cfunction constants)
  261.       (get-function1 effective-method-lambda
  262.              #'(lambda (form)
  263.                  (memf-test-converter form generic-function
  264.                           method-alist-p wrappers-p))
  265.              #'(lambda (form)
  266.                  (memf-code-converter form generic-function
  267.                           metatypes applyp
  268.                           method-alist-p wrappers-p))
  269.              #'(lambda (form)
  270.                  (memf-constant-converter form generic-function)))
  271.     #'(lambda (method-alist wrappers)
  272.         (let* ((constants 
  273.             (mapcar #'(lambda (constant)
  274.                 (if (consp constant)
  275.                     (case (car constant)
  276.                       (.meth.
  277.                        (funcall (cdr constant)
  278.                         method-alist wrappers))
  279.                       (.meth-list.
  280.                        (mapcar #'(lambda (fn)
  281.                            (funcall fn method-alist wrappers))
  282.                            (cdr constant)))
  283.                       (t constant))
  284.                     constant))
  285.                 constants))
  286.            (function (set-function-name
  287.                   (apply cfunction constants)
  288.                   `(combined-method ,name))))
  289.           (make-fast-method-call :function function
  290.                      :arg-info arg-info)))))))
  291.  
  292. (defmacro call-method-list (&rest calls)
  293.   `(progn ,@calls))
  294.  
  295. (defun make-call-methods (methods)
  296.   `(call-method-list
  297.     ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
  298.  
  299. (defun standard-compute-effective-method (generic-function combin applicable-methods)
  300.   (declare (ignore combin))
  301.   (let ((before ())
  302.     (primary ())
  303.     (after ())
  304.     (around ()))
  305.     (dolist (m applicable-methods)
  306.       (let ((qualifiers (if (listp m)
  307.                 (early-method-qualifiers m)
  308.                 (method-qualifiers m))))                
  309.     (cond ((member ':before qualifiers)  (push m before))
  310.           ((member ':after  qualifiers)  (push m after))
  311.           ((member ':around  qualifiers) (push m around))
  312.           (t
  313.            (push m primary)))))
  314.     (setq before  (reverse before)
  315.       after   (reverse after)
  316.       primary (reverse primary)
  317.       around  (reverse around))
  318.     (cond ((null primary)
  319.        `(error "No primary method for the generic function ~S." ',generic-function))
  320.       ((and (null before) (null after) (null around))
  321.        ;;
  322.        ;; By returning a single call-method `form' here we enable an important
  323.        ;; implementation-specific optimization.
  324.        ;; 
  325.        `(call-method ,(first primary) ,(rest primary)))
  326.       (t
  327.        (let ((main-effective-method
  328.            (if (or before after)
  329.                `(multiple-value-prog1
  330.               (progn ,(make-call-methods before)
  331.                  (call-method ,(first primary) ,(rest primary)))
  332.               ,(make-call-methods (reverse after)))
  333.                `(call-method ,(first primary) ,(rest primary)))))
  334.          (if around
  335.          `(call-method ,(first around)
  336.                    (,@(rest around) (make-method ,main-effective-method)))
  337.          main-effective-method))))))
  338.  
  339. ;;;
  340. ;;; The STANDARD method combination type.  This is coded by hand (rather than
  341. ;;; with define-method-combination) for bootstrapping and efficiency reasons.
  342. ;;; Note that the definition of the find-method-combination-method appears in
  343. ;;; the file defcombin.lisp, this is because EQL methods can't appear in the
  344. ;;; bootstrap.
  345. ;;;
  346. ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
  347. ;;; classes has to appear here for this reason.  This code must conform to
  348. ;;; the code in the file defcombin, look there for more details.
  349. ;;;
  350.  
  351. (defun compute-effective-method (generic-function combin applicable-methods)
  352.   (standard-compute-effective-method generic-function combin applicable-methods))
  353.  
  354. (defvar *invalid-method-error*
  355.     #'(lambda (&rest args)
  356.         (declare (ignore args))
  357.         (error
  358.           "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
  359.                of a method combination function (inside the body of~%~
  360.                DEFINE-METHOD-COMBINATION or a method on the generic~%~
  361.                function COMPUTE-EFFECTIVE-METHOD).")))
  362.  
  363. (defvar *method-combination-error*
  364.     #'(lambda (&rest args)
  365.         (declare (ignore args))
  366.         (error
  367.           "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
  368.                of a method combination function (inside the body of~%~
  369.                DEFINE-METHOD-COMBINATION or a method on the generic~%~
  370.                function COMPUTE-EFFECTIVE-METHOD).")))
  371.  
  372. ;(defmethod compute-effective-method :around        ;issue with magic
  373. ;       ((generic-function generic-function)     ;generic functions
  374. ;        (method-combination method-combination)
  375. ;        applicable-methods)
  376. ;  (declare (ignore applicable-methods))
  377. ;  (flet ((real-invalid-method-error (method format-string &rest args)
  378. ;       (declare (ignore method))
  379. ;       (apply #'error format-string args))
  380. ;     (real-method-combination-error (format-string &rest args)
  381. ;       (apply #'error format-string args)))
  382. ;    (let ((*invalid-method-error* #'real-invalid-method-error)
  383. ;      (*method-combination-error* #'real-method-combination-error))
  384. ;      (call-next-method))))
  385.  
  386. (defun invalid-method-error (&rest args)
  387.   (declare (arglist method format-string &rest format-arguments))
  388.   (apply *invalid-method-error* args))
  389.  
  390. (defun method-combination-error (&rest args)
  391.   (declare (arglist format-string &rest format-arguments))
  392.   (apply *method-combination-error* args))
  393.  
  394. ;This definition appears in defcombin.lisp.
  395. ;
  396. ;(defmethod find-method-combination ((generic-function generic-function)
  397. ;                     (type (eql 'standard))
  398. ;                     options)
  399. ;  (when options
  400. ;    (method-combination-error
  401. ;      "The method combination type STANDARD accepts no options."))
  402. ;  *standard-method-combination*)
  403.  
  404.